home *** CD-ROM | disk | FTP | other *** search
/ BBS Toolkit / BBS Toolkit.iso / pc_board / cyb02pdc.zip / PDC.BAS < prev    next >
BASIC Source File  |  1992-07-23  |  9KB  |  255 lines
  1. DECLARE SUB repl (z$, y$, x$)
  2. DECLARE SUB hurl (z!, z$)
  3. DECLARE SUB cast (z$)
  4. DECLARE SUB copyright ()
  5. DECLARE SUB cybertla ()
  6. DECLARE SUB instructions ()
  7. DECLARE SUB oops ()
  8. DECLARE FUNCTION exist! (z$, a!)
  9.  
  10. DIM SHARED h.1, v.1, h.2, v.2 AS INTEGER
  11. DIM SHARED c.b.f, c.b.b AS INTEGER: c.b.f = 1:  c.b.b = 0 ' border
  12. DIM SHARED c.u.f, c.u.b AS INTEGER: c.u.f = 2:  c.u.b = 0 ' text: upper
  13. DIM SHARED c.l.f, c.l.b AS INTEGER: c.l.f = 10: c.l.b = 0 ' text: lower
  14. DIM SHARED c.t.f, c.t.b AS INTEGER: c.t.f = 3:  c.t.b = 0 ' text: message
  15.  
  16. DIM SHARED utla$, unam$, uver$, upar$, udat$
  17. utla$ = "PDC"
  18. unam$ = "PCBoard (File) Description Compressor"
  19. uver$ = "2.00112ß"
  20. upar$ = "sourcefile targetfile"
  21. udat$ = "92/7/23"
  22.  
  23. COLOR 7, 0: WIDTH 80, 25: CLS
  24. COLOR c.t.f, c.t.b
  25. cybertla
  26.  
  27. COLOR 14, 0: LOCATE 1, 1
  28. PRINT " ███▄ ███▄ ▄███ "
  29. PRINT " █▄▄█ █▄▄█ █▄▄▄ "
  30. PRINT " ██   ███▀ ▀███ "
  31. PRINT
  32.  
  33. DIM SHARED bad$
  34. DIM SHARED ps(1 TO 4) AS STRING * 64: pn = 0
  35. z1$ = UCASE$(LTRIM$(RTRIM$(COMMAND$)))
  36. z1 = INSTR(z1$, " ")
  37. DO WHILE (pn < 3) AND (z1 > 0)
  38.    pn = pn + 1
  39.    ps(pn) = LEFT$(z1$, z1 - 1)
  40.    z1$ = MID$(z1$, z1 + 1)
  41.    z1 = INSTR(z1$, " ")
  42. LOOP
  43. IF (pn < 3) AND (LEN(LTRIM$(z1$)) > 0) THEN
  44.    pn = pn + 1
  45.    ps(pn) = z1$
  46. END IF
  47.  
  48. IF RTRIM$(ps(1)) = "" THEN bad$ = "Parameters required": oops: GOTO fin
  49. IF RTRIM$(ps(1)) = "?" THEN instructions: GOTO fin
  50. IF RTRIM$(ps(1)) = "/?" THEN instructions: GOTO fin
  51. IF RTRIM$(ps(1)) = "HELP" THEN instructions: GOTO fin
  52. IF RTRIM$(ps(1)) = "/HELP" THEN instructions: GOTO fin
  53.  
  54. IF pn < 1 THEN bad$ = "sourcefile required (ie: NEW)": oops: GOTO fin
  55. IF pn < 2 THEN bad$ = "targetfile required (ie: NEW.FIX)": oops: GOTO fin
  56. IF pn > 2 THEN bad$ = "Too many variables": oops: GOTO fin
  57. IF exist(ps(1), 1) = 0 THEN bad$ = "No such sourcefile": oops: GOTO fin
  58. IF exist(ps(2), 1) = 1 THEN bad$ = "Targetfile exists": oops: GOTO fin
  59.  
  60. COLOR c.b.f, c.b.b
  61. LOCATE 4, 1: PRINT "┌"; STRING$(78, "─"); "┐";
  62. LOCATE 14, 1: PRINT "├"; STRING$(78, "─"); "┤";
  63. LOCATE 24, 1: PRINT "└"; STRING$(78, "─"); "┘";
  64. FOR r = 1 TO 9
  65.    LOCATE 4 + r, 1: PRINT "│"; : LOCATE 4 + r, 80: PRINT "│";
  66.    LOCATE 14 + r, 1: PRINT "│"; : LOCATE 14 + r, 80: PRINT "│";
  67. NEXT
  68. COLOR c.t.f, c.t.b
  69. LOCATE 25, 1: PRINT " Working, Please standby.";
  70.  
  71. CLOSE #1: OPEN ps(1) FOR INPUT ACCESS READ LOCK WRITE AS #1
  72. CLOSE #2: OPEN ps(2) FOR OUTPUT ACCESS WRITE LOCK READ WRITE AS #2
  73.  
  74. VIEW PRINT 5 TO 13: h.1 = POS(0): v.1 = CSRLIN: v.1 = 13: PRINT
  75. VIEW PRINT 15 TO 23: h.2 = POS(0): v.2 = CSRLIN: v.2 = 23: PRINT
  76.  
  77. locked = 0
  78. specs$ = ""
  79. desc$ = ""
  80. tail$ = ""
  81. DO WHILE EOF(1) = 0
  82.    LINE INPUT #1, z1$
  83.    z1$ = LEFT$(z1$ + STRING$(80, " "), 80)
  84.    z2$ = UCASE$(LTRIM$(RTRIM$(z1$)))
  85.    special = 0
  86.    IF LEFT$(z2$, 15) = "| UPLOADED BY: " THEN special = 1
  87.    ' room for multiple exceptions, date clauses, etc ...
  88.    SELECT CASE special
  89.       CASE 1
  90.          z2$ = MID$(z1$, 32)
  91.          repl z2$, "  ", " "
  92.          hurl 1, STRING$(31, " ") + z2$
  93.          tail$ = STRING$(31, " ") + z2$
  94.          ' could opt to add tail$ to tail$ for many clauses, with CRLFs
  95.       CASE ELSE
  96.          IF locked = 1 THEN status = 1 ELSE status = 0
  97.          IF MID$(z1$, 26, 1) = "-" OR MID$(z1$, 29, 1) = "-" THEN
  98.             status = status + 10
  99.          END IF
  100.          SELECT CASE status
  101.             CASE 0  ' looking for file, line is not a file starter
  102.                hurl 2, z1$
  103.             CASE 1  ' reading description for a file, line is not a file starter
  104.                desc$ = RTRIM$(desc$) + " " + RTRIM$(MID$(z1$, 34))
  105.             CASE 10 ' looking for a file, line contains file info
  106.                locked = 1
  107.                specs$ = LEFT$(z1$, 33)
  108.                desc$ = RTRIM$(MID$(z1$, 34))
  109.             CASE 11 ' reading description for a file, line contains file info
  110.                GOSUB crush
  111.                specs$ = LEFT$(z1$, 33)
  112.                desc$ = RTRIM$(MID$(z1$, 34))
  113.          END SELECT
  114.          hurl 1, z1$
  115.    END SELECT
  116. LOOP
  117. IF locked = 1 THEN GOSUB crush
  118. VIEW PRINT 4 TO 25: COLOR 7, 0: CLS
  119. VIEW PRINT 1 TO 25: LOCATE 5, 1
  120.  
  121. fin:
  122. COLOR c.t.f, c.t.b
  123. copyright
  124. COLOR 7, 0
  125. CLOSE
  126. END
  127.  
  128. crush:
  129.    desc$ = desc$ + " "
  130.    repl desc$, "  ", " "
  131.    first$ = LEFT$(desc$, 46)
  132.    DO WHILE (RIGHT$(first$, 1) <> " ") AND (LEN(first$) > 0)
  133.       first$ = LEFT$(first$, LEN(first$) - 1): LOOP
  134.    IF first$ = "" THEN first$ = LEFT$(desc$, 45)
  135.    hurl 2, specs$ + first$
  136.    remains$ = LTRIM$(MID$(desc$, LEN(first$) + 1))
  137.    DO WHILE LEN(remains$) > 0
  138.       another$ = LEFT$(remains$, 46) ' trailing space already
  139.       DO WHILE (RIGHT$(another$, 1) <> " ") AND (LEN(another$) > 0)
  140.          another$ = LEFT$(another$, LEN(another$) - 1)
  141.       LOOP
  142.       IF another$ = "" THEN another$ = LEFT$(remains$, 45)
  143.       hurl 2, STRING$(31, " ") + "| " + another$
  144.       remains$ = LTRIM$(MID$(remains$, LEN(another$) + 1))
  145.    LOOP
  146.    IF tail$ <> "" THEN
  147.       hurl 2, tail$
  148.       tail$ = ""
  149.    END IF
  150. RETURN
  151.  
  152. SUB cast (z$)
  153. ' z$ : string
  154. '----------------------------------------------------------------------------
  155.    PRINT LEFT$(z$, 79)
  156. END SUB
  157.  
  158. SUB copyright
  159. ' no parameters
  160. '----------------------------------------------------------------------------
  161.    cast utla$ + " (c) Copyright 19" + LEFT$(udat$, 2) + " westsmith"
  162.    cast "You may use these programs in any environment, without any remuneration to me."
  163.    cast "Feel free to distribute copies, as long as all the files are included together"
  164.    cast "in CYB" + RIGHT$("0" + LTRIM$(STR$(INT(VAL(uver$)))), 2) + utla$ + ".* and are not modified. If you find this utility to be of use, do"
  165.    cast "yourself a favour and pick up a copy of NEUROMANCER, by William Gibson."
  166.    PRINT
  167. END SUB
  168.  
  169. SUB cybertla
  170. ' no parameters
  171. '----------------------------------------------------------------------------
  172.    cast "                 ¬¥⌐ " + utla$ + " " + uver$ + " " + unam$
  173.    cast "                 <<> westsmith " + udat$ + ", The FlatEarth BBS, CyberNET 1:416/803.0"
  174.    cast "                     A Cybertool, " + qq$ + "Long live William Gibson." + qq$
  175.    PRINT
  176. END SUB
  177.  
  178. FUNCTION exist (z$, a)
  179. ' z$ : filename to check for
  180. ' a  : filenumber to use
  181. '----------------------------------------------------------------------------
  182.    CLOSE #a: OPEN z$ FOR BINARY ACCESS WRITE LOCK READ WRITE AS a
  183.    IF LOF(a) = 0 THEN
  184.       CLOSE #a
  185.       KILL z$
  186.       exist = 0
  187.    ELSE
  188.       exist = 1
  189.    END IF
  190.    CLOSE #a
  191. END FUNCTION
  192.  
  193. SUB hurl (z, z$)
  194.    IF z = 1 THEN
  195.       VIEW PRINT 5 TO 13: LOCATE v.1, h.1: PRINT : LOCATE v.1, h.1
  196.       z1 = c.u.f: z2 = c.u.b
  197.    ELSE
  198.       PRINT #2, RTRIM$(z$)
  199.       VIEW PRINT 15 TO 23: LOCATE v.2, h.2: PRINT : LOCATE v.2, h.2
  200.       z1 = c.l.f: z2 = c.l.b
  201.    END IF
  202.    COLOR c.b.f, c.b.b: PRINT "│";
  203.    COLOR z1, z2: PRINT LEFT$(z$ + STRING$(78, " "), 78);
  204.    COLOR c.b.f, c.b.b: PRINT "│";
  205.    IF z = 1 THEN
  206.       h.1 = POS(0): v.1 = CSRLIN
  207.    ELSE
  208.       h.2 = POS(0): v.2 = CSRLIN
  209.    END IF
  210. END SUB
  211.  
  212. SUB instructions
  213. ' no parameters
  214. '----------------------------------------------------------------------------
  215.    COLOR 10, 0
  216.    cast "    Format: " + utla$ + " " + upar$
  217.    PRINT
  218.    COLOR 2, 0
  219.    cast " [█] " + qq$ + "WHY WOULD I WANT TO COMPRESS MY PCBOARD FILE DESCRIPTIONS?" + qq$
  220.    cast "  └─ PCBoard's rather handy capacity for directly inserting file descriptions"
  221.    cast "     can save a sysop a lot of work but the standard ID file doesn't use the"
  222.    cast "     full default width that PCBoard allows, spreading text across less-than"
  223.    cast "     full lines. This can mean several extra screens-full of listing for users."
  224.    cast ""
  225.    cast "     " + utla$ + " will read in the full description for each file, remove extra spaces"
  226.    cast "     and then re-write the text using as few lines as possible. The sourcefile"
  227.    cast "     should be a regular PCBoard directory listing, which can be replaced by"
  228.    cast "     the targetfile once " + utla$ + " has finished."
  229.    PRINT
  230. END SUB
  231.  
  232. SUB oops
  233. ' no parameters
  234. '----------------------------------------------------------------------------
  235.    COLOR 12, 0
  236.    cast " <!> ERROR: " + bad$
  237.    cast "            Type " + utla$ + " /HELP for basic instructions"
  238.    cast ""
  239.    cast "    Format: " + utla$ + " " + upar$
  240.    PRINT
  241. END SUB
  242.  
  243. SUB repl (z$, y$, x$)
  244. ' z$ : string to work on
  245. ' y$ : replace
  246. ' x$ : with
  247. '----------------------------------------------------------------------------
  248.    z = INSTR(z$, y$)
  249.    DO WHILE z > 0
  250.       z$ = LEFT$(z$, z - 1) + x$ + MID$(z$, z + LEN(y$))
  251.       z = INSTR(z$, y$)
  252.    LOOP
  253. END SUB
  254.  
  255.